home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / cobparam.zip / TESTPARM.COB < prev    next >
Text File  |  1990-11-19  |  3KB  |  80 lines
  1. 000100 IDENTIFICATION DIVISION.
  2. 000200 PROGRAM-ID. TESTPARM.
  3. 000300*
  4. 000400 AUTHOR.       PAUL LYNN.
  5. 000500           2904 BUCKSKIN TRAIL
  6. 000600           MARIETTA, GA 30064
  7. 000700*=================================================================
  8. 000800*  This Program is Realia Cobol Source Code....
  9. 000900*
  10. 001000*  THE MAIN PURPOSE OF THIS PROGRAM IS TO ILLUSTRATE HOW THE
  11. 001100*    COMMAND LINE PARAMETERS CAN BE EXTRACTED FOR
  12. 001200*    USE WITHIN A PROGRAM.
  13. 001300*
  14. 001400*  COMMAND LINE PARAMETERS ARE EXTRACTED
  15. 001500*    AND PUT INTO THE WORKING STORAGE TABLE FOR LATER USE.
  16. 001600*
  17. 001700*  TO RUN THE PROGRAM ENTER THE FOLLOWING:
  18. 001800*
  19. 001900*  TESTPARM (UP TO SIX Parameters) Whatever you want.......
  20. 002000*      ec.   Testparm  Test1 Test2 Test3 Test4 Test5 Test6
  21. 002100*=================================================================
  22. 002200*
  23. 002300 ENVIRONMENT DIVISION.
  24. 002400 CONFIGURATION SECTION.
  25. 002500 SOURCE-COMPUTER. IBM-PC.
  26. 002600 OBJECT-COMPUTER. IBM-PC.
  27. 002700*
  28. 002800 INPUT-OUTPUT SECTION.
  29. 002900 FILE-CONTROL.
  30. 003000 DATA DIVISION.
  31. 003100*
  32. 003200 FILE SECTION.
  33. 003300*
  34. 003400 WORKING-STORAGE SECTION.
  35. 003500*
  36. 003600 01  WS-P-PARAMS-AREA.
  37. 003700       03  WS-P-PARAM                   OCCURS  6 TIMES.
  38. 003800           05  WS-P-PARAM-CHAR     PIC X           OCCURS 60 TIMES.
  39. 003900 01  PARAM-SUB               PIC 9(3)        VALUE 1.
  40. 004000 01  PARAM-SUB1               PIC 9(3)        VALUE 1.
  41. 004100 01  PARAM-SUB2               PIC 9(3)        VALUE 0.
  42. 004200*
  43. 004300 01  PARAMETER.
  44. 004400       03  PARM-LENGTH           PIC S9(04) COMP-4.
  45. 004500       03  FILLER               PIC X.
  46. 004600       03  PARM-CHARS.
  47. 004700           05 PARM-CHAR           PIC X OCCURS 1 TO 120 TIMES
  48. 004800                         DEPENDING ON PARM-LENGTH.
  49. 004900 PROCEDURE DIVISION.
  50. 005000*
  51. 005100 GET-PARM-STRING.
  52. 005200*
  53. 005300     CALL 'DOS_GET_PARMS' USING PARAMETER.
  54. 005400*
  55. 005500       IF PARM-LENGTH = 0
  56. 005600           GO TO GET-PARAM-END.
  57. 005700*
  58. 005800       PERFORM VARYING PARAM-SUB FROM 1 BY 1
  59. 005900          UNTIL PARAM-SUB = PARM-LENGTH
  60. 006000          IF PARAM-SUB1 < 7
  61. 006100           IF PARM-CHAR(PARAM-SUB) NOT EQUAL ' '
  62. 006200             ADD 1 TO PARAM-SUB2
  63. 006300             MOVE PARM-CHAR(PARAM-SUB) TO
  64. 006400              WS-P-PARAM-CHAR(PARAM-SUB1, PARAM-SUB2)
  65. 006500         ELSE
  66. 006600            ADD 1 TO PARAM-SUB1
  67. 006700            MOVE 0 TO PARAM-SUB2
  68. 006800          END-IF
  69. 006900       END-IF
  70. 007000       END-PERFORM.
  71. 007100 GET-PARAM-END.
  72. 007200*
  73. 007300       IF PARAM-SUB1 > 6
  74. 007400          MOVE 6        TO PARAM-SUB1.
  75. 007500       PERFORM VARYING PARAM-SUB FROM 1 BY 1
  76. 007600          UNTIL PARAM-SUB > PARAM-SUB1
  77. 007700        DISPLAY 'PARAM ' PARAM-SUB ' = ' WS-P-PARAM(PARAM-SUB)
  78. 007800       END-PERFORM.
  79. 007900     STOP RUN.
  80.